home *** CD-ROM | disk | FTP | other *** search
/ PD Collection CD 1 / PD Collection CD 1.iso / programer2 / lisp / xlisp / !XLisp_h_XLISP < prev    next >
Encoding:
Text File  |  1990-02-24  |  10.7 KB  |  330 lines
  1. /* xlisp - a small subset of lisp */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. /* system specific definitions */
  7. #define unix
  8. #define Risc 
  9.  
  10. #include <stdio.h>
  11. #include <ctype.h> 
  12. #ifndef MEGAMAX
  13. #include <setjmp.h>
  14. #endif
  15.  
  16. /* NNODES       number of nodes to allocate in each request (1000) */
  17. /* TDEPTH       trace stack depth (500) */
  18. /* EDEPTH       evaluation stack depth (1000) */
  19. /* FORWARD      type of a forward declaration () */
  20. /* LOCAL        type of a local function (static) */
  21. /* AFMT         printf format for addresses ("%x") */
  22. /* FIXNUM       data type for fixed point numbers (long) */
  23. /* ITYPE        fixed point input conversion routine type (long atol()) */
  24. /* ICNV         fixed point input conversion routine (atol) */
  25. /* IFMT         printf format for fixed point numbers ("%ld") */
  26. /* FLONUM       data type for floating point numbers (float) */
  27. /* SYSTEM       enable the control-d command */
  28.  
  29. /* absolute value macros */
  30. #ifndef abs
  31. #define abs(n)  ((n) < 0 ? -(n) : (n))
  32. #endif
  33. #ifndef fabs
  34. #define fabs(n) ((n) < 0.0 ? -(n) : (n))
  35. #endif
  36.  
  37. /* for the MegaMax compiler */
  38. #ifdef MEGAMAX
  39. #define LOCAL
  40. #define AFMT            "%lx"
  41. #endif
  42.  
  43. /* for the AZTEC C compiler - small model */
  44. #ifdef AZTEC_SM
  45. #define SYSTEM
  46. #define NIL             0
  47. #endif
  48.  
  49. /* for the AZTEC C compiler - large model */
  50. #ifdef AZTEC_LM
  51. #define FLONUM          double
  52. #define SYSTEM
  53. #define NIL             0L
  54. #endif
  55.  
  56. /* for the Lattice C compiler (Amiga) */
  57. #ifdef LATTICE
  58. #undef fabs
  59. #endif
  60.  
  61. /* default important definitions */
  62. #ifndef NNODES
  63. #define NNODES          1000
  64. #endif
  65. #ifndef TDEPTH
  66. #define TDEPTH          500
  67. #endif
  68. #ifndef EDEPTH
  69. #define EDEPTH          1000
  70. #endif
  71. #ifndef FORWARD
  72. #define FORWARD
  73. #endif
  74. #ifndef LOCAL
  75. #define LOCAL           static
  76. #endif
  77. #ifndef AFMT
  78. #define AFMT            "%x"
  79. #endif
  80. #ifndef FIXNUM
  81. #define FIXNUM          long
  82. #endif
  83. #ifndef ITYPE
  84. #define ITYPE           long atol()
  85. #endif
  86. #ifndef ICNV
  87. #define ICNV(n)         atol(n)
  88. #endif
  89. #ifndef IFMT
  90. #define IFMT            "%ld"
  91. #endif
  92. #ifndef FLONUM
  93. #define FLONUM          float
  94. #endif
  95.  
  96. /* useful definitions */
  97. #define TRUE    1
  98. #define FALSE   0
  99. #ifndef NIL
  100. #define NIL     (NODE *)0
  101. #endif
  102.  
  103. /* program limits */
  104. #define STRMAX          100             /* maximum length of a string constant */
  105. #define HSIZE           199             /* symbol hash table size */
  106. #define SAMPLE          100             /* control character sample rate */
  107.         
  108. /* node types */
  109. #define FREE    0
  110. #define SUBR    1
  111. #define FSUBR   2
  112. #define LIST    3
  113. #define SYM     4
  114. #define INT     5
  115. #define STR     6
  116. #define OBJ     7
  117. #define FPTR    8
  118. #define FLOAT   9
  119. #define VECT    10
  120.  
  121. /* node flags */
  122. #define MARK    1
  123. #define LEFT    2
  124.  
  125. /* string types */
  126. #define DYNAMIC 0
  127. #define STATIC  1
  128.  
  129. /* new node access macros */
  130. #define ntype(x)        ((x)->n_type)
  131.  
  132. /* type predicates */
  133. #define atom(x)         ((x) == NIL || (x)->n_type != LIST)
  134. #define null(x)         ((x) == NIL)
  135. #define listp(x)        ((x) == NIL || (x)->n_type == LIST)
  136. #define consp(x)        ((x) && (x)->n_type == LIST)
  137. #define subrp(x)        ((x) && (x)->n_type == SUBR)
  138. #define fsubrp(x)       ((x) && (x)->n_type == FSUBR)
  139. #define stringp(x)      ((x) && (x)->n_type == STR)
  140. #define symbolp(x)      ((x) && (x)->n_type == SYM)
  141. #define filep(x)        ((x) && (x)->n_type == FPTR)
  142. #define objectp(x)      ((x) && (x)->n_type == OBJ)
  143. #define fixp(x)         ((x) && (x)->n_type == INT)
  144. #define floatp(x)       ((x) && (x)->n_type == FLOAT)
  145. #define vectorp(x)      ((x) && (x)->n_type == VECT)
  146.  
  147. /* cons access macros */
  148. #define car(x)          ((x)->n_car)
  149. #define cdr(x)          ((x)->n_cdr)
  150. #define rplaca(x,y)     ((x)->n_car = (y))
  151. #define rplacd(x,y)     ((x)->n_cdr = (y))
  152.  
  153. /* symbol access macros */
  154. #define getvalue(x)     ((x)->n_symvalue)
  155. #define setvalue(x,v)   ((x)->n_symvalue = (v))
  156. #define getplist(x)     ((x)->n_symplist->n_cdr)
  157. #define setplist(x,v)   ((x)->n_symplist->n_cdr = (v))
  158. #define getpname(x)     ((x)->n_symplist->n_car)
  159.  
  160. /* vector access macros */
  161. #define getsize(x)      ((x)->n_vsize)
  162. #define getelement(x,i) ((x)->n_vdata[i])
  163. #define setelement(x,i,v) ((x)->n_vdata[i] = (v))
  164.  
  165. /* object access macros */
  166. #define getclass(x)     ((x)->n_vdata[0])
  167. #define getivar(x,i)    ((x)->n_vdata[i+1])
  168. #define setivar(x,i,v)  ((x)->n_vdata[i+1] = (v))
  169.  
  170. /* subr/fsubr access macros */
  171. #define getsubr(x)      ((x)->n_subr)
  172.  
  173. /* fixnum/flonum access macros */
  174. #define getfixnum(x)    ((x)->n_int)
  175. #define getflonum(x)    ((x)->n_float)
  176.  
  177. /* string access macros */
  178. #define getstring(x)    ((x)->n_str)
  179. #define setstring(x,v)  ((x)->n_str = (v))
  180.  
  181. /* file access macros */
  182. #define getfile(x)      ((x)->n_fp)
  183. #define setfile(x,v)    ((x)->n_fp = (v))
  184. #define getsavech(x)    ((x)->n_savech)
  185. #define setsavech(x,v)  ((x)->n_savech = (v))
  186.  
  187. /* symbol node */
  188. #define n_symplist      n_info.n_xsym.xsy_plist
  189. #define n_symvalue      n_info.n_xsym.xsy_value
  190.  
  191. /* subr/fsubr node */
  192. #define n_subr          n_info.n_xsubr.xsu_subr
  193.  
  194. /* list node */
  195. #define n_car           n_info.n_xlist.xl_car
  196. #define n_cdr           n_info.n_xlist.xl_cdr
  197.  
  198. /* integer node */
  199. #define n_int           n_info.n_xint.xi_int
  200.  
  201. /* float node */
  202. #define n_float         n_info.n_xfloat.xf_float
  203.  
  204. /* string node */
  205. #define n_str           n_info.n_xstr.xst_str
  206. #define n_strtype       n_info.n_xstr.xst_type
  207.  
  208. /* file pointer node */
  209. #define n_fp            n_info.n_xfptr.xf_fp
  210. #define n_savech        n_info.n_xfptr.xf_savech
  211.  
  212. /* vector/object node */
  213. #define n_vsize         n_info.n_xvect.xv_size
  214. #define n_vdata         n_info.n_xvect.xv_data
  215.  
  216. /* node structure */
  217. typedef struct node {
  218.     char n_type;                /* type of node */
  219.     char n_flags;               /* flag bits */
  220.     union {                     /* value */
  221.         struct xsym {           /* symbol node */
  222.             struct node *xsy_plist;     /* symbol plist - (name . plist) */
  223.             struct node *xsy_value;     /* the current value */
  224.         } n_xsym;
  225.         struct xsubr {          /* subr/fsubr node */
  226.             struct node *(*xsu_subr)(); /* pointer to an internal routine */
  227.         } n_xsubr;
  228.         struct xlist {          /* list node (cons) */
  229.             struct node *xl_car;        /* the car pointer */
  230.             struct node *xl_cdr;        /* the cdr pointer */
  231.         } n_xlist;
  232.         struct xint {           /* integer node */
  233.             FIXNUM xi_int;              /* integer value */
  234.         } n_xint;
  235.         struct xfloat {         /* float node */
  236.             FLONUM xf_float;            /* float value */
  237.         } n_xfloat;
  238.         struct xstr {           /* string node */
  239.             int xst_type;               /* string type */
  240.             char *xst_str;              /* string pointer */
  241.         } n_xstr;
  242.         struct xfptr {          /* file pointer node */
  243.             FILE *xf_fp;                /* the file pointer */
  244.             int xf_savech;              /* lookahead character for input files */
  245.         } n_xfptr;
  246.         struct xvect {          /* vector node */
  247.             int xv_size;                /* vector size */
  248.             struct node **xv_data;      /* vector data */
  249.         } n_xvect;
  250.     } n_info;
  251. } NODE;
  252.  
  253. /* execution context flags */
  254. #define CF_GO           1
  255. #define CF_RETURN       2
  256. #define CF_THROW        4
  257. #define CF_ERROR        8
  258. #define CF_CLEANUP      16
  259. #define CF_CONTINUE     32
  260. #define CF_TOPLEVEL     64
  261.  
  262. /* execution context */
  263. typedef struct context {
  264.     int c_flags;                        /* context type flags */
  265.     struct node *c_expr;                /* expression (type dependant) */
  266.     jmp_buf c_jmpbuf;                   /* longjmp context */
  267.     struct context *c_xlcontext;        /* old value of xlcontext */
  268.     struct node ***c_xlstack;           /* old value of xlstack */
  269.     struct node *c_xlenv;               /* old value of xlenv */
  270.     int c_xltrace;                      /* old value of xltrace */
  271. } CONTEXT;
  272.  
  273. /* function table entry structure */
  274. struct fdef {
  275.     char *f_name;                       /* function name */
  276.     int f_type;                         /* function type SUBR/FSUBR */
  277.     struct node *(*f_fcn)();            /* function code */
  278. };
  279.  
  280. /* memory segment structure definition */
  281. struct segment {
  282.     int sg_size;
  283.     struct segment *sg_next;
  284.     struct node sg_nodes[1];
  285. };
  286.  
  287. /* external procedure declarations */
  288. extern struct node ***xlsave();         /* generate a stack frame */
  289. extern struct node *xleval();           /* evaluate an expression */
  290. extern struct node *xlapply();          /* apply a function to arguments */
  291. extern struct node *xlevlist();         /* evaluate a list of arguments */
  292. extern struct node *xlarg();            /* fetch an argument */
  293. extern struct node *xlevarg();          /* fetch and evaluate an argument */
  294. extern struct node *xlmatch();          /* fetch an typed argument */
  295. extern struct node *xlevmatch();        /* fetch and evaluate a typed arg */
  296. extern struct node *xlgetfile();        /* fetch a file/stream argument */
  297. extern struct node *xlsend();           /* send a message to an object */
  298. extern struct node *xlenter();          /* enter a symbol */
  299. extern struct node *xlsenter();         /* enter a symbol with a static pname */
  300. extern struct node *xlmakesym();        /* make an uninterned symbol */
  301. extern struct node *xlframe();          /* establish a new environment frame */
  302. extern struct node *xlgetvalue();       /* get value of a symbol (checked) */
  303. extern struct node *xlxgetvalue();      /* get value of a symbol */
  304. extern struct node *xlygetvalue();      /* get value of a symbol (no ivars) */
  305.  
  306. extern struct node *cons();             /* (cons x y) */
  307. extern struct node *consa();            /* (cons x nil) */
  308. extern struct node *consd();            /* (cons nil x) */
  309.  
  310. extern struct node *cvsymbol();         /* convert a string to a symbol */
  311. extern struct node *cvcsymbol();        /* (same but constant string) */
  312. extern struct node *cvstring();         /* convert a string */
  313. extern struct node *cvcstring();        /* (same but constant string) */
  314. extern struct node *cvfile();           /* convert a FILE * to a file */
  315. extern struct node *cvsubr();           /* convert a function to a subr/fsubr */
  316. extern struct node *cvfixnum();         /* convert a fixnum */
  317. extern struct node *cvflonum();         /* convert a flonum */
  318.  
  319. extern struct node *newstring();        /* create a new string */
  320. extern struct node *newvector();        /* create a new vector */
  321. extern struct node *newobject();        /* create a new object */
  322.  
  323. extern struct node *xlgetprop();        /* get the value of a property */
  324. extern char *xlsymname();               /* get the print name of a symbol */
  325.  
  326. extern void xlsetvalue();
  327. extern void xlprint();
  328. extern void xltest();
  329.  
  330.